Megarom/Megarom Macintosh CD Software (Quantum Leap)(1992).iso/COMPRESS/DeHQX-200/Source/ReadHQX.p

Text File | 1991-08-23 | 12.6 KB | 558 lines | [TEXT/PJMM]

unit ReadHQX;
{ DeHQX v2.0.0 © Peter Lewis, Aug 1991 }

interface

    uses
        MyTypes, MyFileSystem, AppGlobals, MyUtilities, CRCs, Preferences, Displays, HQXLists, MyMainLoop, SmallEvents;

    type
        hqxInfo = record
                name: str63;
                wdrn: integer;
                dirID: longInt;
                c, t: OSType;
                flags: integer;
                dlen, rlen: longInt;
            end;

    var
        crc: integer;

    procedure InitReadHQX;
    procedure FinishReadHQX;
    procedure ReInitReadHQX;
    function OpenHQX: OSErr;
    procedure FinishHQX;
    procedure CreateFolder (var ovrn: integer; var odirID: longInt);
    function ReadByte (var b: byte): OSErr;
    function ReadColon: OSErr;
    function ReadInteger (var b: integer): OSErr;
    function ReadLong (var b: longInt): OSErr;
    function ReadOSType (var t: OSType): OSErr;
    function ReadString (var s: str255): OSErr;
    function ReadHeader (var hi: hqxInfo; wp: windowPtr): OSErr;

implementation

    const
        buffer_slop = 70;        { Amount of lookahead required to scan for beginstr }
        buffer_size = 16384;
        dud_byte = 255;
        cr = 13;
        lf = 10;
        spc = 32;
        bad_filern = -32000;

    var
        thevalue: packed array[0..255] of byte;
        state: 0..6;
        value: byte;
        repeating: boolean;
        repvalue: byte;
        repcount: integer;
        startstr, beginstr: str63;
        blen: integer;        { blen=length(beginstr) }
        read_hqx_byte: longInt;  { incremented for each read hqx byte, if it exceeds buffer_slop }
{ I will accept the file for deletion. }
        infile: integer;
        buffer: packed array[0..buffer_size] of byte;
        buffer_len: integer;
        finished_files: boolean;
        default_ovrn: integer;
        default_odirID: longInt;
        create_folder: boolean;

    procedure CreateFolder (var ovrn: integer; var odirID: longInt);
        var
            oe: OSErr;
            pb: CInfoPBRec;
            dirID: longInt;
            s: str255;
    begin
        ovrn := default_ovrn;
        odirID := default_odirID;
        if create_folder then begin
            oe := DirCreate(ovrn, odirID, GetGlobalString(folder_name), dirID);
            if oe <> noErr then begin
                with pb do begin
                    s := GetGlobalString(folder_name);
                    ioNamePtr := @s;
                    ioVRefNum := ovrn;
                    ioFDirIndex := 0;
                    ioDirID := odirID;
                    oe := PBGetCatInfo(@pb, false);
                    if oe = noErr then begin
                        if BAND(ioFlAttrib, $0010) <> 0 then begin
                            odirID := ioDirID;
                        end;
                    end;
                end;
            end
            else
                odirID := dirID;
            default_odirID := odirID;
            create_folder := false;
        end;
    end;

    procedure InitReadHQX;
        var
            i: integer;
            s: str255;
    begin
        GetIndString(s, hqx_strh_id, 3);
        for i := 0 to 255 do
            thevalue[i] := dud_byte;
        for i := 1 to 64 do begin
            thevalue[ord(s[i])] := i - 1;
        end;
        startstr := GetIndStrSize(sizeof(startstr), hqx_strh_id, 1);
        beginstr := GetIndStrSize(sizeof(beginstr), hqx_strh_id, 2);
        blen := length(beginstr) - 1;
        InitHQXLists;
    end;

    procedure ReInitReadHQX;
    begin
        state := 0;
        value := 0;
        repeating := false;
        repcount := 0;
    end;

    procedure FinishReadHQX;
    begin
        FinishHQXLists;
    end;

    function ReadBuffer: OSErr;
{ NOTE: must have  buffer_len-buffer_slop<=buffer_pos<=buffer_len }
        var
            bl: longInt;
            oe: OSErr;
            bs: integer;
    begin
        if (buffer_pos = 0) and (buffer_len = buffer_size) then
            oe := myErr
        else begin
            bs := buffer_len - buffer_pos;
            if bs > 0 then
                BlockMove(@buffer[buffer_pos], @buffer[0], bs);
            size_processed := size_processed + buffer_pos;
            buffer_pos := 0;
            bl := buffer_size - bs;
            oe := FSRead(infile, bl, @buffer[bs]);
            if oe = eofErr then
                oe := noErr;
            if bl = 0 then
                oe := eofErr;
            if oe <> noErr then
                bl := 0;
            buffer_len := bl + bs;
        end;
        ReadBuffer := oe;
    end;

    function OpenEitherHQX: OSErr;
        var
            oe, ooe: OSErr;
            dirID: longInt;
            name: str63;
    begin
        if AnyFilesLeft then begin
            GetNextFile(default_ovrn, default_odirID, name, create_folder);
            oe := MFSOpenDF(infile, default_ovrn, default_odirID, name, PIn);
            if oe = noErr then
                oe := ReadBuffer
            else
                infile := bad_filern;
            read_hqx_byte := 0;
        end
        else
            oe := fnfErr;
        OpenEitherHQX := oe;
    end;

    function OpenHQX: OSErr;
    begin
        buffer_len := 1;
        buffer_pos := 1;
        finished_files := false;
        OpenHQX := OpenEitherHQX
    end;

    function OpenOtherHQX: OSErr;
        var
            ooe: OSErr;
    begin
        if infile <> bad_filern then begin
            ooe := FSClose(infile);
            infile := bad_filern;
            FinishFile(read_hqx_byte > buffer_slop);
{ yick.  Its the only way I figure I can safely delete a file, given all the buffering going on }
        end;
        OpenOtherHQX := OpenEitherHQX;
    end;

    procedure FinishHQX;
        var
            ooe: OSErr;
    begin
        if infile <> bad_filern then
            ooe := FSClose(infile);
    end;

    function FileReadByte (var b: byte): OSErr;
        var
            oe: OSErr;
    begin  { Some of this code is expanded inline in other procedures, so be careful modifying it }
        if buffer_pos < buffer_len - buffer_slop then begin
            b := buffer[buffer_pos];
            buffer_pos := buffer_pos + 1;
            FileReadByte := noErr;
        end
        else begin
            oe := noErr;
            if finished_files then begin
                if buffer_pos >= buffer_len then
                    oe := fnfErr;
            end
            else begin
                while (buffer_pos >= buffer_len - buffer_slop) and (oe = noErr) do
                    oe := ReadBuffer;
                while oe = eofErr do
                    oe := OpenOtherHQX;
                if oe = fnfErr then begin
                    if buffer_pos < buffer_len then
                        oe := noErr;
                    finished_files := true;
                end;
            end;
            if oe = noErr then begin
                b := buffer[buffer_pos];
                buffer_pos := buffer_pos + 1;
            end;
            FileReadByte := oe;
        end;
    end;

    function ReadAByte (var b: byte): OSErr;
        var
            oe: OSErr;
            i: integer;
        procedure RB;
            var
                b: byte;
            label
                1;
        begin
            if buffer_pos < buffer_len - buffer_slop then begin
                b := buffer[buffer_pos];
                buffer_pos := buffer_pos + 1;
                oe := noErr;
                if b <= spc then
                    goto 1;
                value := thevalue[b];
                if value = dud_byte then
                    oe := HqxFormatErr;
            end
            else begin
                oe := FileReadByte(b);
1:        { skip <cr>, and check for <cr>--- end of part }
                if b <= spc then {short cut most of this expression for the normal case }
                    if oe = noErr then begin
                        while (oe = noErr) and (b <= spc) do
                            oe := FileReadByte(b);
                        if b = ord(beginstr[1]) then
                            if prefs.parts_state then
                                if (buffer[buffer_pos] = ord(beginstr[2])) and (buffer_pos + blen - 2 <= buffer_len) then begin
                                    i := 3;
                                    while (buffer[buffer_pos + i - 2] = ord(beginstr[i])) and (i < blen) do begin
                                        i := i + 1;
                                    end;
                                    if i = blen then begin {skiping headers - waiting for a <cr>---<cr> }
                                        buffer_pos := buffer_pos + i - 2;
                                        repeat
                                            repeat
                                                while (oe = noErr) and (b >= spc) do
                                                    oe := FileReadByte(b);
                                                while (oe = noErr) and (b < spc) do
                                                    oe := FileReadByte(b);
                                            until (oe <> noErr) or (b = ord('-'));
                                        until (oe <> noErr) or ((buffer[buffer_pos] = b) and (buffer[buffer_pos + 1] = b) and (buffer[buffer_pos + 2] <= spc));
                                        if oe = noErr then
                                            oe := FileReadByte(b);  { '-' }
                                        if oe = noErr then
                                            oe := FileReadByte(b);  { '-' }
                                        if oe = noErr then
                                            oe := FileReadByte(b);  { cr }
                                        if oe = noErr then
                                            oe := FileReadByte(b);  { next char }
                                        if oe = noErr then
                                            goto 1;
                                    end; { if i=blen }
                                end; { if parts_state }
                    end; { if b<=spc }
                if oe = noErr then begin
                    value := thevalue[b];
                    if value = dud_byte then
                        oe := HqxFormatErr;
                end;
            end;
        end;
    begin
        case state of
            0:
                begin
                RB;
                b := BAND(BSL(value, 2), $FF);
                if oe = noErr then
                    RB;
                b := BOR(b, BSR(value, 4));
                state := 2;
            end;
            2:
                begin
                b := BAND(BSL(value, 4), $FF);
                RB;
                b := BOR(b, BSR(value, 2));
                state := 4;
            end;
            4:
                begin
                b := BAND(BSL(value, 6), $FF);
                RB;
                b := BOR(b, value);
                state := 0;
            end;
            otherwise
                oe := myErr;
        end;
        ReadAByte := oe;
    end;

    function ReadByte (var b: byte): OSErr;
        label
            1;
        var
            oe: OSErr;
    begin
        if repeating then begin
            oe := noErr;
            repcount := repcount - 1;
            repeating := repcount > 0;
            b := repvalue;
        end
        else begin
1:
            oe := ReadAByte(b);
            if b = $90 then
                if oe = noErr then begin
                    oe := ReadAByte(b);
                    if oe = noErr then
                        if b = 0 then
                            b := $90
                        else begin
                            if b < 2 then
                                goto 1;
                            repcount := b - 2;
                            repeating := repcount > 0;
                            b := repvalue;
                        end;
                end;
        end;
        CalcCRC(crc, b);
        read_hqx_byte := read_hqx_byte + 1;
        repvalue := b;
        ReadByte := oe;
    end;

    function ReadColon: OSErr;
        var
            b: byte;
            oe: OSErr;
    begin
        oe := FileReadByte(b);
        if (oe = noErr) and (b = ord('!')) then         { slight kludge, beets me why! }
            oe := FileReadByte(b);
        if (oe = noErr) and (b <> ord(':')) then
            oe := hqxFormatErr;
        ReadColon := oe;
    end;

{$PUSH}
{$R-}
    function ReadInteger (var b: integer): OSErr;
        var
            b1, b2: byte;
            oe: OSErr;
    begin
        oe := ReadByte(b1);
        if oe = noErr then
            oe := ReadByte(b2);
        if oe = noErr then
            b := BOR(BSL(b1, 8), b2);
        ReadInteger := oe;
    end;

    function ReadLong (var b: longInt): OSErr;
        var
            b1, b2, b3, b4: byte;
            oe: OSErr;
    begin
        oe := ReadByte(b1);
        if oe = noErr then
            oe := ReadByte(b2);
        if oe = noErr then
            oe := ReadByte(b3);
        if oe = noErr then
            oe := ReadByte(b4);
        if oe = noErr then
            b := BOR(BOR(BOR(BSL(b1, 24), BSL(b2, 16)), BSL(b3, 8)), b4);
        ReadLong := oe;
    end;
{$POP}

    function ReadOSType (var t: OSType): OSErr;
    begin
        ReadOSType := ReadLong(longInt(t));
    end;

    function ReadString (var s: str255): OSErr;
        var
            oe: OSErr;
            len, ch: byte;
    begin
        oe := ReadByte(len);
        s := '';
        while (oe = noErr) and (len > 0) do begin
            oe := ReadByte(ch);
            s := concat(s, chr(ch));
            len := len - 1;
        end;
        ReadString := oe;
    end;

    function FindStart (wp: windowPtr): OSErr;
        var
            oe: OSErr;
            b: byte;
            dummy_reply: HEReply;
            slen, i, cnt: integer;
            startchar: byte;
    begin
        slen := length(startstr);
        startchar := ord(startstr[1]);
        cnt := 1;
        oe := noErr;
        while (oe = noErr) do begin
            repeat
                if buffer_pos < buffer_len - buffer_slop then begin
                    b := buffer[buffer_pos];
                    buffer_pos := buffer_pos + 1;
                end
                else begin
                    oe := FileReadByte(b);
                    if oe <> noErr then begin
                        FindStart := oe;
                        exit(FindStart);
                    end;
                end;
                cnt := cnt - 1;
                if cnt < 1 then begin
                    DisplayUpdate(wp);
                    cnt := 1024;
                    HandleCancelErrorEvents(0, nil, oe, dummy_reply);
                    if oe <> noErr then begin
                        FindStart := oe;
                        exit(FindStart);
                    end;
                end;
            until (b = startchar) or (b = ord(':'));
            if (b = startchar) and (buffer_len >= buffer_pos + slen) then begin
                i := 2;
                while (buffer[buffer_pos + i - 2] = ord(startstr[i])) and (i < slen) do begin
                    i := i + 1;
                end;
                if i = slen then begin
                    buffer_pos := buffer_pos + i - 2;
                    oe := FileReadByte(b);
                    while (oe = noErr) and (b >= spc) do
                        oe := FileReadByte(b);
                    while (oe = noErr) and (b <= spc) do
                        oe := FileReadByte(b);
                    if (oe <> noErr) or (b = ord(':')) then begin
                        FindStart := oe;
                        exit(FindStart);
                    end;
                end
            end
            else if not prefs.demand_thisfile_state and (buffer_len >= buffer_pos + 64) then
                if (b = ord(':')) and (buffer[buffer_pos + 63] < spc) then begin
                    i := 0;
                    while (thevalue[buffer[buffer_pos + i]] <> dud_byte) and (i < 63) do begin
                        i := i + 1;
                    end;
                    if (i = 63) then begin
                        FindStart := oe;
                        exit(FindStart);
                    end;
                end;
        end;
        FindStart := oe;
    end;

    function ReadHeader (var hi: hqxInfo; wp: windowPtr): OSErr;
        var
            oe: OSErr;
            b: byte;
            hc: integer;
            actcrc: integer;
            nam: str255;
            i: integer;
    begin
        with hi do begin
            ReInitReadHQX;
            oe := FindStart(wp);
            crc := 0;
            if oe = noErr then
                oe := ReadString(nam);
            if (oe = noErr) and ((length(nam) > 63) or (length(nam) < 1)) then
                oe := HqxFormatErr;                        { certainly not a proper HQX file }
            if oe = noErr then begin
                name := nam;
                if name[1] = '.' then
                    name[1] := '•';    { Don't create files with names starting with '.' }
                for i := 1 to length(name) do begin
                    if name[i] = ':' then
                        name[i] := '-';
                end;
            end;
            if oe = noErr then
                oe := ReadByte(b);
            if (oe = noErr) and (b <> 0) then
                oe := HqxFormatErr;
            if oe = noErr then
                oe := ReadOSType(t);
            if oe = noErr then
                oe := ReadOSType(c);
            if oe = noErr then
                oe := ReadInteger(flags);
            if oe = noErr then
                oe := ReadLong(dlen);
            if oe = noErr then
                oe := ReadLong(rlen);
            if oe = noErr then begin
                CalcCRC(crc, 0);
                CalcCRC(crc, 0);
                actcrc := crc;
                oe := ReadInteger(hc);
                if (actcrc <> hc) and (oe = noErr) then
                    oe := HqxFormatErr;
            end;
        end;
        ReadHeader := oe;
    end;

end.